perm filename M11B.F4[M11,LCS]2 blob sn#396924 filedate 1978-11-22 generic text, type T, neo UTF8
00100	CGEN1      FUNCTION GENERATOR 1 
00200	C    *** MUSIC V ***     
00300	      SUBROUTINEGEN1     
00400	      COMMON I(1)/P/ P(1) /GENS/GENS(1)
00500		1 /LFUNC/LFUNC
00600	      N1=1+(IFIX(P(4))-1)*LFUNC     
00700	      M1=7 
00800	 102  M=M1+1
00900	      IF(P(M).LE.0)GO TO 103
01000	      V1=P(M1-2)
01100	      V2=(P(M1)-P(M1-2))/(P(M)-P(M1-1))
01200	      MA=N1+IFIX(P(M1-1))
01300	      MB=N1+IFIX(P(M))-1     
01400	      DO 101 J=MA,MB
01500	      XJ=J-MA     
01600	 101  GENS(J)=V1+V2*XJ      
01700	      IF(IFIX(P(M)).EQ.(LFUNC-1))GO TO 103   
01800	      M1=M1+2     
01900	      GO TO 102     
02000	 103  GENS(MB+1)=P(M1)
02100	      RETURN      
02200	      END  
02300	
02400	CGEN2      FUNCTION GENERATOR 2 
02500	C    *** MUSIC V ***     
02600	      SUBROUTINEGEN2     
02700	      COMMON I(1)/P/ P(1) /GENS/GENS(1)
02800		1 /LFUNC/LFUNC
02900	      N1=1+(IFIX(P(4))-1)*LFUNC    
03000	      N2=N1+LFUNC-1      
03100	      DO 101 K1=N1,N2      
03200	 101  GENS(K1)=0.0   
03300	      FAC=6.283185/(FLOAT(LFUNC)-1.0)  
03400	      NMAX=I(1)   
03500	      N3=5+INT(ABS(P(NMAX)))-1  
03600	      IF(N3-5.LT.0)GO TO 104
03700	      DO 103 J=5,N3 
03800	      FACK=FAC*FLOAT(J-4)
03900	      DO 102 K=N1,N2
04000	 102  GENS(K)=GENS(K)+SIN(FACK*FLOAT(K-N1))*P(J)    
04100	 103  CONTINUE    
04200	 104  N4=N3+1     
04300	      N5=I(1)-1   
04400	      IF(N5-N4.LT.0)GO TO 114
04500	      DO 107 J1=N4,N5      
04600	      FACK=FAC*FLOAT(J1-N4)     
04700	      DO 106 K1=N1,N2      
04800	 106  GENS(K1)=GENS(K1)+COS(FACK*FLOAT(K1-N1))*P(J1)
04900	 107  CONTINUE    
05000	114   IF(P(NMAX).LE.0)GO TO 112
05100	      FMAX=0.0    
05200	      DO 110  K2=N1,N2      
05300	      A=ABS(GENS(K2))
05400	110   IF(FMAX.LT.A)FMAX=A
05500	 113  DO 111 K3=N1,N2      
05600	 111  GENS(K3)=GENS(K3)/FMAX  
05700	      RETURN      
05800	112   FMAX=.99999 
05900	      GO TO 113     
06000	      END  
06100	
06200	CPARM      CONTROL DATA SPECIFICATION FOR PASS 3     
06300	C    *** MUSIC V ***     
06400	C   
06500	C     IP(1) = NUMBER OF OP CODES
06600	C     IP(2) = BEGINNING SUBSCRIPT OF FIRST FUNCTION  
06700	C     IP(3) = STANDARD SAMPLING RATE   
06800	C     IP(4) = BEGINNING SUBSCRIPT OF INSTRUMENT DEFINITIONS 
06900	C     IP(5) = BEGINNING OF LOCATION TABLE FOR INSTRUMENT DEFINITIONS      
07000	C     IP(6) = LENGTH OF FUNCTIONS      
07100	C     IP(7) = BEGINNING OF NOTE CARD PARAMETERS      
07200	C     IP(8) = LENGTH OF NOTE CARD PARAMETER BLOCKS   
07300	C     IP(9) = NUMBER OF NOTE CARD PARAMETER BLOCKS   
07400	C     IP(10)= BEGINNING OF OUTPUT DATA BLOCK  
07500	C     IP(11)= SOUND ZERO (SILENCE VALUE)      
07600	C     IP(12)= SCALE FACTOR FOR NOTE CARD PARAMETERS  
07700	C     IP(13)= BEGINNING OF GENERATOR INPUT-OUTPUT BLOCKS    
07800	C     IP(14)= LENGTH OF GENERATOR INPUT-OUTPUT BLOCKS
07900	C     IP(15)= SCALE FACTOR FOR FUNCTIONS      
08000	C   
08100	CS    BLOCK DATA  
08200	CS    COMMON /PARM/IP(20)
08300	CS    DATA IP/12,512,10000, 7100, 7000,512, 6000,35,27,4487,2048,  
08400	CS   1   10     ,4487,512,  "77777  ,5*0/
08500	CCC   DATA IP/12,512,10000,14500,14400,512,13000,35,40,6657,2048,  
08600	CCC  1  "1000000,6657,512,"377777777777,5*0/
08700	C*****BIG NUMB. IS IBM360'S BIGGEST.  1  65536,6657,512,Z7FFFFFFF/      
08800	CS    END  
08900	
09000	
09100	CDSMOUT   DEBUG SAMOUT     'C////'=CHANGES FOR PDP11 VERSION
09200	C *** MUSIC V *** 
09300	C     DEBUG SAMOUT
09400	      SUBROUTINE SAMOUT(IDSK,N)    
09500		COMMON I(1)  /ROUT/ROUT(1)  /FINOUT/PEAK,IPEAK,NBUF
09600		1 /CONV/CONV,INIOUT,JFLNM
09700	      DIMENSION IDBUF(2048),JDBUF(512),NN(512),LDBUF(512)
09800	 	EQUIVALENCE (IDBUF,JDBUF),(LDBUF,IDBUF(513))
09900	C*** IDBUF WILL STORE PACKED SAMPLES. ****
10000	CSS      INTEGER PEAK
10100		IF(INIOUT.EQ.0)GO TO 99
10200	C NOW OPEN PROPER OUTPUT FILE
10300		INIOUT=0
10400		IDSK=0
10500		IF(CONV.EQ.0)GO TO 199
10600		CALL PUTFILE('11')
10700		NN(1)="525252525252
10800		NN(2)=I(4)
10900	C I(4)=SRATE, I(8)=NCHNS(-1),  FOR NEXT, 18 BIT SMPLS.
11000		NN(3)=1
11100		NN(4)=I(8)+1
11200		NN(5)=33000
11300		DO 299 K=6,128
11400	299	NN(K)=0
11500		CALL FASTOU(NN,128)
11600		GO TO 99
11700	C  OUTPUT IS ALWAYS NAMED 'TEST.DAT' FOR NOW.
11800	CX199X	CALL OPEN(23,'TEST',0,'NEW',,,'UNF')
11900	199   	CALL OFILE(23,'TEST')
12000	99    J=IDSK+1
12100		M1=1
12200	      M2=0
12300	      IDSK=IDSK+N
12400	C  COUNTS SAMPLES TO DATE
12500	      DO 1 K=J,IDSK
12600	      S=ROUT(M1+M2)
12700		A=ABS(S)
12800	      IF(A.GT.PEAK)PEAK=A
12900		IF(CONV.NE.0)S=S*32.
13000	C *32 TO CONVERT 12 BIT AMPL RANGE TO 16 BIT RANGE.
13100	      IDBUF(K)=S
13200	1     M2=M2+1
13300	      IF(IDSK.LT.NBUF)RETURN
13400	C NBUF=512,MONO   =1024,STEREO
13500	
13600		IF(CONV.EQ.0)GO TO 11
13700		M=1
13800		J=NBUF/2
13900		DO 44 K=1,J
14000		NN(K)=(IDBUF(M)*"1000000).OR.(IDBUF(M+1).AND."777777)
14100	C  PACKS 2 SMPLS PER WORD.
14200	CC	NN(K)=IDBUF(M)*262144+IDBUF(M+1)
14300	C 16*262144=4194304
14400	44	M=M+2
14500	CZ3     IF(MS(L).LT.0)MS(L)=4096+MS(L)
14600	CZ2     IDBUF(KL)=MS(3)+MS(2)*4096+MS(1)*16777216
14700	C PACKS 3 SMPLS TO A 36-BIT WORD. 4096=2**12, 16---=2**24.
14800	C  MS(1) HAS LEFT HAND 12 BITS; MS(2), MIDDLE 12 BITS; MS(3), RIGHT 12.
14900	C  NEGATIVE NUMBERS RUN FROM 4095(I.E. -1) TO 2049(I.E. -2048).
15000		CALL FASTOU(NN,J)
15100		GO TO 10
15200	
15300	11	WRITE(23)JDBUF
15400		IF(NBUF.NE.512)WRITE(23),LDBUF
15500	C ABOVE FOR STEREO
15600	10    J=IDSK-NBUF
15700	      IF(J.LT.1)GO TO 4
15800	      DO 5 K=1,J
15900	5     IDBUF(K)=IDBUF(NBUF+K)
16000	4     IDSK=J
16100	      RETURN
16200	      END  
16300	
16400	CERRO1     GENERAL ERROR ROUTINE
16500	C    *** MUSIC V ***     
16600	      SUBROUTINE ERROR(I) 
16700	      TYPE 100,I  
16800	  100 FORMAT (' ERROR OF TYPE',I5)     
16900	      RETURN      
17000	      END